perm filename TEST.F4[M11,LCS]1 blob sn#404807 filedate 1978-12-16 generic text, type T, neo UTF8
00100		DIMENSION INP(80)
00110		DATA IBLA/' '/,ISEMI/';'/
00400	888	FORMAT(80A1)
00500	889	FORMAT(1XA5)
00600	890	FORMAT(' TYPE'/)
00650	891	FORMAT(1X80A1)
00700	5	TYPE 890
00800		ACCEPT 888,INP
00810		DO 1 J=1,80
00820	1	IF(INP(J).EQ.IBLA.OR.INP(J).EQ.ISEMI)GO TO 2
00830	2	JJ=J
00835		J=J-1
00840		N=J
00850		IF(J.GT.5)N=4
00860		DO 3 M=80,1,-1
00870	3	IF(INP(M).NE.IBLA)GO TO 4
00880		GO TO 5
00900	4	CALL PACKER(NN,INP,N)
00910	C NN BRINGS BACK PACKED NAME, INP IS ARRAY, N IS WDCNT.
01000		TYPE 889,NN
01010	70	DO 7 I=1,M-JJ
01020	7	INP(I)=INP(I+JJ)
01030		DO 8 I=M-J,M
01040	8	INP(I)=IBLA
01050		M=M-JJ
01100		TYPE 891,(INP(K),K=1,M)
01200		END
01300	
04000		SUBROUTINE PACKER(NN,JNM,N)
04100		DIMENSION JNM(1),KNM(5)
04200		DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
04300		DATA MM/"774000000000/,IBLA/' '/
04400	
04410		DO 10 K=1,5
04420		IF(K.GT.N)GO TO 11
04430		KNM(K)=JNM(K)
04440		GO TO 10
04450	11	KNM(K)=IBLA
04460	10	CONTINUE
05000	C N=WDCNT OF INST NAME
05100		NN=0
05200		DO 12 K=5,1,-1
05300		NN=NN .OR. (KNM(K) .AND. MM)
05400		IF (K.EQ.1)RETURN
05500	17	IF (NN.GE.0)GO TO 13
05600		NN = (( NN .AND. LL)/KK) .OR. JJ
05700		GO TO 12
05800	13	NN = NN / KK
05900	12	CONTINUE
06100		END